00100	BEGIN	"HEAP SORT"
00200		REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
00300		REQUIRE "RANDOM[SYS,BGB]" SOURCE_FILE;
00400		REQUIRE "TIMER[SYS,BGB]" SOURCE_FILE;
00500	
00600		INTEGER ARRAY A[1:10000];
00700	
00800	PROCEDURE HEAPSORT (INTEGER ARRAY A; INTEGER N);
00900	BEGIN	"HEAPSORT"
01000		INTEGER I,J,K;
01100		INTEGER X,Q;
01200	α PHASE ONE, PUT 'EM UNDER THE HEAP & BIGGIES TRICKLE UP;
01300		FOR K←2 STEP 1 UNTIL N DO
01400		BEGIN
01500			I←K;
01600			X←A[K];
01700			WHILE I>1 ∧ X>A[J←I%2] DO
01800			BEGIN A[I]←A[J]; I←J END;
01900			A[I]←X;
02000		END;
02100	α PHASE TWO, TAKE 'EM OFF THE TOP & PROMOTE SUBORDINATES;
02200		FOR K←N STEP -1 UNTIL 2 DO
02300		BEGIN
02400			X←A[K];A[K]←A[1];I←1;
02500			WHILE (J←2*I)<K DO
02600			BEGIN
02700				IF A[J+1]>A[J] ∧ (J+1)<K THEN J←J+1;
02800				IF X≥A[J] THEN DONE ELSE
02900				BEGIN A[I]←A[J];I←J;END;
03000			END;
03100			A[I]←X;
03200		END;
03300	END	"HEAPSORT";
03400	
03500		INTEGER Q;
03600		FOR Q←1 STEP 1 UNTIL 1000 DO A[Q]←1000*RANDOM;
03700		INTIME;
03800		HEAPSORT(A,1000);
03900		FOR Q←1 STEP 1 UNTIL 1000-1 DO
04000		IF A[Q]>A[Q+1] THEN BEGIN OUTSTR("SORT ERROR ! ");INCHRW;END;
04100		OUTIME;
04200		INCHRW;
04300	END	"HEAP SORT";